home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / FSTRUCT.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  17.1 KB  |  676 lines
  1. /*
  2.  * File: fstruct.r
  3.  *  Contents: delete, get, key, insert, list, member, pop, pull, push, put,
  4.  *  set, table
  5.  */
  6.  
  7. "delete(x1,x2) - delete element x2 from set or table x1 if it is there"
  8. " (always succeeds and returns x1)."
  9.  
  10. function{1} delete(s,x)
  11.    abstract {
  12.       return type(s) ** (set ++ table)
  13.       }
  14.  
  15.    /*
  16.     * The technique and philosophy here are the same
  17.     *  as used in insert - see comment there.
  18.     */
  19.    type_case s of {
  20.       set:
  21.          body {
  22.             register uword hn;
  23.             register union block **pd;
  24.             union block *bp;     /* does not need to be tended. */
  25.             int res;
  26.  
  27.             hn = hash(&x);
  28.  
  29.             pd = memb(BlkLoc(s), &x, hn, &res);
  30.             if (res == 1) {
  31.                /*
  32.                * The element is there so delete it.
  33.                */
  34.                *pd = (*pd)->selem.clink;
  35.                (BlkLoc(s)->set.size)--;
  36.                }
  37.             return s;
  38.         }
  39.       table:
  40.          body {
  41.             union block *bp;     /* does not need to be tended. */
  42.             register union block **pd;
  43.             register uword hn;
  44.             int res;
  45.  
  46.             hn = hash(&x);
  47.             pd = memb(BlkLoc(s), &x, hn, &res);
  48.             if (res == 1) {
  49.                /*
  50.                * The element is there so delete it.
  51.                */
  52.                *pd = (*pd)->selem.clink;
  53.                (BlkLoc(s)->set.size)--;
  54.                }
  55.             return s;
  56.             }
  57.       default:
  58.          runerr(122, s)
  59.       }
  60. end
  61.  
  62.  
  63. /*
  64.  * c_get - convenient C-level access to the get function
  65.  *  returns 0 on failure, otherwise fills in res
  66.  */
  67. int c_get(hp,res)
  68. struct b_list *hp;
  69. struct descrip *res;
  70. {
  71.    register word i;
  72.    register struct b_lelem *bp;
  73.  
  74.    /*
  75.     * Fail if the list is empty.
  76.     */
  77.    if (hp->size <= 0)
  78.       return 0;
  79.  
  80.    /*
  81.     * Point bp at the first list block.  If the first block has no
  82.     *  elements in use, point bp at the next list block.
  83.     */
  84.    bp = (struct b_lelem *) hp->listhead;
  85.    if (bp->nused <= 0) {
  86.       bp = (struct b_lelem *) bp->listnext;
  87.       hp->listhead = (union block *) bp;
  88.       bp->listprev = NULL;
  89.       }
  90.  
  91.    /*
  92.     * Locate first element and assign it to result for return.
  93.     */
  94.    i = bp->first;
  95.    *res = bp->lslots[i];
  96.  
  97.    /*
  98.     * Set bp->first to new first element, or 0 if the block is now
  99.     *  empty.  Decrement the usage count for the block and the size
  100.     *  of the list.
  101.     */
  102.    if (++i >= bp->nslots)
  103.       i = 0;
  104.    bp->first = i;
  105.    bp->nused--;
  106.    hp->size--;
  107.  
  108.    return 1;
  109. }
  110.  
  111. #begdef GetOrPop(get_or_pop)
  112. #get_or_pop "(x) - " #get_or_pop " an element from the left end of list x."
  113. /*
  114.  * get(L) - get an element from end of list L.
  115.  *  Identical to pop(L).
  116.  */
  117. function{0,1} get_or_pop(x)
  118.    if !is:list(x) then
  119.       runerr(108, x)
  120.  
  121.    abstract {
  122.       return store[type(x).lst_elem]
  123.       }
  124.  
  125.    body {
  126.       if (!c_get((struct b_list *)BlkLoc(x),&result)) fail;
  127.       return result;
  128.       }
  129. end
  130. #enddef
  131.  
  132. GetOrPop(get) /* get(x) - get an element from the left end of list x. */
  133. GetOrPop(pop) /* pop(x) - pop an element from the left end of list x. */
  134.  
  135.  
  136. "key(T) - generate successive keys (entry values) from table T."
  137.  
  138. function{*} key(t)
  139.    if !is:table(t) then
  140.          runerr(124, t)
  141.  
  142.    abstract {
  143.       return store[type(t).key]
  144.       }
  145.  
  146.    inline {
  147.       tended union block *ep;
  148.       struct hgstate state;
  149.  
  150.       for (ep = hgfirst(BlkLoc(t), &state); ep != 0;
  151.      ep = hgnext(BlkLoc(t), &state, ep))
  152.             suspend ep->telem.tref;
  153.       fail;
  154.       }
  155. end
  156.  
  157.  
  158. "insert(x1,x2,x3) - insert element x2 into set or table x1 if not already there"
  159. " if x1 is a table, the assigned value for element x2 is x3."
  160. " (always succeeds and returns x1)."
  161.  
  162. function{1} insert(s,x,y)
  163.    type_case s of {
  164.  
  165.       set: {
  166.          abstract {
  167.             store[type(s).set_elem] = type(x)
  168.             return type(s)
  169.             }
  170.  
  171.          body {
  172.             tended union block *bp, *bp2;
  173.             register uword hn;
  174.             int res;
  175.             struct b_selem *se;
  176.             register union block **pd;
  177.  
  178.             bp = BlkLoc(s);
  179.             hn = hash(&x);
  180.             /*
  181.              * If x is a member of set s then res will have the value 1,
  182.              *  and pd will have a pointer to the pointer
  183.              *  that points to that member.
  184.              *  If x is not a member of the set then res will have
  185.              *  the value 0 and pd will point to the pointer
  186.              *  which should point to the member - thus we know where
  187.              *  to link in the new element without having to do any
  188.              *  repetitive looking.
  189.              */
  190.  
  191.         /* get this now because can't tend pd */
  192.             Protect(se = alcselem(&x,hn), runerr(0));
  193.  
  194.             pd = memb(bp, &x, hn, &res);
  195.             if (res == 0) {
  196.                /*
  197.                * The element is not in the set - insert it.
  198.                */
  199.                addmem((struct b_set *)bp, se, pd);
  200.                if (TooCrowded(bp))
  201.                   hgrow(bp);
  202.                }
  203.         else
  204.            deallocate((union block *)se);
  205.             return s;
  206.             }
  207.          }
  208.  
  209.       table: {
  210.          abstract {
  211.             store[type(s).key] = type(x)
  212.             store[type(s).tbl_elem] = type(y)
  213.             return type(s)
  214.             }
  215.  
  216.          body {
  217.             tended union block *bp, *bp2;
  218.             union block **pd;
  219.             struct b_telem *te;
  220.             register uword hn;
  221.             int res;
  222.  
  223.             bp = BlkLoc(s);
  224.             hn = hash(&x);
  225.  
  226.         /* get this now because can't tend pd */
  227.             Protect(te = alctelem(), runerr(0));
  228.  
  229.             pd = memb(bp, &x, hn, &res);    /* search table for key */
  230.             if (res == 0) {
  231.                /*
  232.                * The element is not in the table - insert it.
  233.                */
  234.                bp->table.size++;
  235.                te->clink = *pd;
  236.                *pd = (union block *)te;
  237.                te->hashnum = hn;
  238.                te->tref = x;
  239.                te->tval = y;
  240.                if (TooCrowded(bp))
  241.                   hgrow(bp);
  242.                }
  243.             else {
  244.            /*
  245.         * We found an existing entry; just change its value.
  246.         */
  247.            deallocate((union block *)te);
  248.                te = (struct b_telem *) *pd;
  249.                te->tval = y;
  250.                }
  251.             return s;
  252.             }
  253.          }
  254.  
  255.       default:
  256.          runerr(122, s);
  257.       }
  258. end
  259.  
  260.  
  261. "list(i,x) - create a list of size i, with initial value x."
  262.  
  263. function{1} list(n,x)
  264.    if !def:C_integer(n,0L) then
  265.       runerr(101, n)
  266.  
  267.    abstract {
  268.       return new list(type(x))
  269.       }
  270.  
  271.    body {
  272.       tended struct b_list *hp;
  273.       register word i, size;
  274.       word nslots;
  275.       register struct b_lelem *bp; /* does not need to be tended */
  276.  
  277.       nslots = size = n;
  278.  
  279.       /*
  280.        * Ensure that the size is positive and that the list-element block 
  281.        *  has at least MinListSlots slots.
  282.        */
  283.       if (size < 0) {
  284.          irunerr(205, n);
  285.          errorfail;
  286.          }
  287.       if (nslots == 0)
  288.          nslots = MinListSlots;
  289.  
  290.       /*
  291.        * Allocate the list-header block and a list-element block.
  292.        *  Note that nslots is the number of slots in the list-element
  293.        *  block while size is the number of elements in the list.
  294.        */
  295.       Protect(hp = alclist(size), runerr(0));
  296.       Protect(bp = alclstb(nslots, (word)0, size), runerr(0));
  297.       hp->listhead = hp->listtail = (union block *) bp;
  298.  
  299.       /*
  300.        * Initialize each slot.
  301.        */
  302.       for (i = 0; i < size; i++)
  303.          bp->lslots[i] = x;
  304.  
  305.       /*
  306.        * Return the new list.
  307.        */
  308.       return list(hp);
  309.       }
  310. end
  311.  
  312.  
  313. "member(x1,x2) - returns x1 if x2 is a member of set or table x2 but fails"
  314. " otherwise."
  315.  
  316. function{0,1} member(s,x)
  317.    type_case s of {
  318.  
  319.       set: {
  320.          abstract {
  321.             return type(x) ** store[type(s).set_elem]
  322.             }
  323.          inline {
  324.             int res;
  325.             register uword hn;
  326.  
  327.             hn = hash(&x);
  328.             memb(BlkLoc(s),&x,hn,&res);
  329.             if (res==1)
  330.                return x;
  331.             else
  332.                fail;
  333.             }
  334.          }
  335.       table: {
  336.          abstract {
  337.             return type(x) ** store[type(s).key]
  338.             }
  339.          inline {
  340.             int res;
  341.             register uword hn;
  342.  
  343.             hn = hash(&x);
  344.             memb(BlkLoc(s),&x,hn,&res);
  345.             if (res == 1)
  346.                return x;
  347.             else
  348.                fail;
  349.             }
  350.          }
  351.       default:
  352.          runerr(122, s)
  353.       }
  354. end
  355.  
  356.  
  357. "pull(L) - pull an element from end of list L."
  358.  
  359. function{0,1} pull(x)
  360.    /*
  361.     * x must be a list.
  362.     */
  363.    if !is:list(x) then
  364.       runerr(108, x)
  365.    abstract {
  366.       return store[type(x).lst_elem]
  367.       }
  368.  
  369.    body {
  370.       register word i;
  371.       register struct b_list *hp;
  372.       register struct b_lelem *bp;
  373.  
  374.       /*
  375.        * Point at list header block and fail if the list is empty.
  376.        */
  377.       hp = (struct b_list *) BlkLoc(x);
  378.       if (hp->size <= 0)
  379.          fail;
  380.  
  381.       /*
  382.        * Point bp at the last list element block.  If the last block has no
  383.        *  elements in use, point bp at the previous list element block.
  384.        */
  385.       bp = (struct b_lelem *) hp->listtail;
  386.       if (bp->nused <= 0) {
  387.          bp = (struct b_lelem *) bp->listprev;
  388.          hp->listtail = (union block *) bp;
  389.          bp->listnext = NULL;
  390.          }
  391.  
  392.       /*
  393.        * Set i to position of last element and assign the element to
  394.        *  result for return.  Decrement the usage count for the block
  395.        *  and the size of the list.
  396.        */
  397.       i = bp->first + bp->nused - 1;
  398.       if (i >= bp->nslots)
  399.          i -= bp->nslots;
  400.       result = bp->lslots[i];
  401.       bp->nused--;
  402.       hp->size--;
  403.       return result;
  404.       }
  405. end
  406.  
  407.  
  408.  
  409. "push(L,x) - push x onto beginning of list L."
  410.  
  411. function{1} push(x,val)
  412.    /*
  413.     * x must be a list.
  414.     */
  415.    if !is:list(x) then
  416.       runerr(108, x)
  417.    abstract {
  418.       store[type(x).lst_elem] = type(val)
  419.       return type(x)
  420.       }
  421.  
  422.    body {
  423.       tended struct b_list *hp;
  424.       register word i;
  425.       register struct b_lelem *bp; /* does not need to be tended */
  426.       static two = 2;        /* some compilers generat bad code for
  427.                    division by a constant that's a power of 2*/
  428.       /*
  429.        * Point hp at the list-header block and bp at the first
  430.        *  list-element block.
  431.        */
  432.       hp = (struct b_list *) BlkLoc(x);
  433.       bp = (struct b_lelem *) hp->listhead;
  434.  
  435. #ifdef EventMon     /* initialize i so it's 0 if first list-element */
  436.       i = 0;            /* block isn't full */
  437. #endif                /* EventMon */
  438.  
  439.       /*
  440.        * If the first list-element block is full, allocate a new
  441.        *  list-element block, make it the first list-element block,
  442.        *  and make it the previous block of the former first list-element
  443.        *  block.
  444.        */
  445.       if (bp->nused >= bp->nslots) {
  446.          /*
  447.           * Set i to the size of block to allocate.
  448.           */
  449.          i = hp->size / two;
  450.          if (i < MinListSlots)
  451.             i = MinListSlots;
  452. #ifdef MaxListSlots
  453.      if (i > MaxListSlots)
  454.             i = MaxListSlots;
  455. #endif                    /* MaxListSlots */
  456.  
  457.          /*
  458.           * Allocate a new list element block.  If the block can't
  459.           *  be allocated, try smaller blocks.
  460.           */
  461.          while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  462.         i /= 4;
  463.         if (i < MinListSlots)
  464.            runerr(0);
  465.         }
  466.  
  467.          hp->listhead->lelem.listprev = (union block *) bp;
  468.          bp->listnext = hp->listhead;
  469.          hp->listhead = (union block *) bp;
  470.          }
  471.  
  472.       /*
  473.        * Set i to position of new first element and assign val to
  474.        *  that element.
  475.        */
  476.       i = bp->first - 1;
  477.       if (i < 0)
  478.          i = bp->nslots - 1;
  479.       bp->lslots[i] = val;
  480.       /*
  481.        * Adjust value of location of first element, block usage count,
  482.        *  and current list size.
  483.        */
  484.       bp->first = i;
  485.       bp->nused++;
  486.       hp->size++;
  487.       /*
  488.        * Return the list.
  489.        */
  490.       return x;
  491.       }
  492. end
  493.  
  494.  
  495.  
  496. "put(L,x) - put x onto end of list L."
  497.  
  498. function{1} put(x,val)
  499.    /*
  500.     * x must be a list.
  501.     */
  502.    if !is:list(x) then
  503.       runerr(108, x)
  504.    abstract {
  505.       store[type(x).lst_elem] = type(val)
  506.       return type(x)
  507.       }
  508.  
  509.    body {
  510.       tended struct b_list *hp;
  511.       register word i;
  512.       register struct b_lelem *bp;  /* does not need to be tended */
  513.       static two = 2;        /* some compilers generate bad code for
  514.                    division by a constant that's a power of 2*/
  515.       /*
  516.        * Point hp at the list-header block and bp at the last
  517.        *  list-element block.
  518.        */
  519.       hp = (struct b_list *)BlkLoc(x);
  520.       bp = (struct b_lelem *) hp->listtail;
  521.    
  522. #ifdef EventMon     /* initialize i so it's 0 if last list-element */
  523.       i = 0;            /* block isn't full */
  524. #endif                /* EventMon */
  525.  
  526.       /*
  527.        * If the last list-element block is full, allocate a new
  528.        *  list-element block, make it the last list-element block,
  529.        *  and make it the next block of the former last list-element
  530.        *  block.
  531.        */
  532.       if (bp->nused >= bp->nslots) {
  533.      /*
  534.       * Set i to the size of block to allocate.
  535.       */
  536.      i = hp->size / two;
  537.      if (i < MinListSlots)
  538.         i = MinListSlots;
  539. #ifdef MaxListSlots
  540.      if (i > MaxListSlots)
  541.         i = MaxListSlots;
  542. #endif                    /* MaxListSlots */
  543.          /*
  544.           * Allocate a new list element block.  If the block can't
  545.           *  be allocated, try smaller blocks.
  546.           */
  547.          while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  548.         i /= 4;
  549.         if (i < MinListSlots)
  550.            runerr(0);
  551.         }
  552.  
  553.      hp->listtail->lelem.listnext = (union block *) bp;
  554.      bp->listprev = hp->listtail;
  555.      hp->listtail = (union block *) bp;
  556.          }
  557.  
  558.       /*
  559.        * Set i to position of new last element and assign val to
  560.        *  that element.
  561.        */
  562.       i = bp->first + bp->nused;
  563.       if (i >= bp->nslots)
  564.      i -= bp->nslots;
  565.       bp->lslots[i] = val;
  566.  
  567.       /*
  568.        * Adjust block usage count and current list size.
  569.        */
  570.       bp->nused++;
  571.       hp->size++;
  572.       /*
  573.        * Return the list.
  574.        */
  575.       return x;
  576.       }
  577. end
  578.  
  579.  
  580. "set(L) - create a set with members in list L."
  581. "  The members are linked into hash chains which are"
  582. " arranged in increasing order by hash number."
  583.  
  584. function{1} set(l)
  585.  
  586.    type_case l of {
  587.       null: {
  588.          abstract {
  589.             return new set(empty_type)
  590.             }
  591.          inline {
  592.             register union block * ps;
  593.             ps = hmake(T_Set, (word)0, (word)0);
  594.             if (ps == NULL)
  595.                runerr(0);
  596.             return set(ps);
  597.             }
  598.          }
  599.  
  600.       list: {
  601.          abstract {
  602.             return new set(store[type(l).lst_elem])
  603.             }
  604.  
  605.          body {
  606.             tended union block *pb;
  607.             register uword hn;
  608.             dptr pd;
  609.             struct b_selem *ne;      /* does not need to be tended */
  610.             int res;
  611.             word i, j;
  612.             tended union block *ps;
  613.             union block **pe;
  614.  
  615.             /*
  616.              * Make a set of the appropriate size.
  617.              */
  618.             pb = BlkLoc(l);
  619.             ps = hmake(T_Set, (word)0, pb->list.size);
  620.             if (ps == NULL)
  621.                runerr(0);
  622.  
  623.             /*
  624.              * Chain through each list block and for
  625.              *  each element contained in the block
  626.              *  insert the element into the set if not there.
  627.          *
  628.          * ne always has a new element ready for use.  We must get one
  629.          *  in advance, and stay one ahead, because pe can't be tended.
  630.          */
  631.         Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0));
  632.  
  633.             for (pb = pb->list.listhead; pb != NULL; pb = pb->lelem.listnext) {
  634.                for (i = 0; i < pb->lelem.nused; i++) {
  635.                   j = pb->lelem.first + i;
  636.                   if (j >= pb->lelem.nslots)
  637.                      j -= pb->lelem.nslots;
  638.                   pd = &pb->lelem.lslots[j];
  639.                   pe = memb(ps, pd, hn = hash(pd), &res);
  640.                   if (res == 0) {
  641.              ne->setmem = *pd;            /* add new element */
  642.              ne->hashnum = hn;
  643.                      addmem((struct b_set *)ps, ne, pe);
  644.                             /* get another blk */
  645.                  Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0));
  646.                      }
  647.                   }
  648.                }
  649.         deallocate((union block *)ne);
  650.             return set(ps);
  651.             }
  652.          }
  653.  
  654.       default :
  655.          runerr(108, l)
  656.       }
  657. end
  658.  
  659.  
  660. "table(x) - create a table with default value x."
  661.  
  662. function{1} table(x)
  663.    abstract {
  664.       return new table(empty_type, empty_type, type(x))
  665.       }
  666.    inline {
  667.       union block *bp;
  668.    
  669.       bp = hmake(T_Table, (word)0, (word)0);
  670.       if (bp == NULL)
  671.          runerr(0);
  672.       bp->table.defvalue = x;
  673.       return table(bp);
  674.       }
  675. end
  676.